home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 5.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  32.1 KB  |  1,246 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* Todo: 
  10.  
  11.  3-12-86    ds    
  12.  Modify format of as_return node so that new node of type as_number
  13.  put in N_AST3 field to hold depth count formerly kept in N_VAL.
  14.  
  15.  30-oct-84    ds
  16.  Note that N_VAL for node produced at end of return_statement()
  17.  is different, is now integer giving depth, was tuple of length two.
  18.  
  19.  
  20. id is defined in goto_statement but never used
  21.  
  22. */
  23.  
  24. #include "attr.h"
  25. #include "hdr.h"
  26. #include "vars.h"
  27. #include "setprots.h"
  28. #include "dclmapprots.h"
  29. #include "miscprots.h"
  30. #include "errmsgprots.h"
  31. #include "dbxprots.h"
  32. #include "evalprots.h"
  33. #include "nodesprots.h"
  34. #include "smiscprots.h"
  35. #include "chapprots.h"
  36.  
  37. #define label_unreachable 0
  38. #define label_reachable 1
  39.  
  40. static void new_symbol(Symbol, int, Symbol, Tuple, Symbol);
  41. static Const get_static_nval(Node);
  42. static void replace_others(Node, Node, int, int);
  43.  
  44. Symbol slice_type(Node node, int is_renaming)         /*;slice_type*/
  45. {
  46.     Node   array_node, range_node, low_node, high_node, type_node;
  47.     Node   new_range_node, arg1, arg2, var_node;
  48.     Symbol type_name, type_mark, index_name, i_type;
  49.     Tuple  tup;
  50.     int    attr_prefix, kind;
  51.  
  52.     /* We must have a subtype for the aggregate to give the bounds */
  53.     if (is_renaming) {
  54.         var_node = N_AST3(node);
  55.     } 
  56.     else
  57.         var_node = N_AST1(node);
  58.     array_node = N_AST1(var_node);
  59.     range_node = N_AST2(var_node);
  60.     kind = N_KIND(range_node);
  61.     if (kind == as_simple_name || kind == as_name)
  62.         type_name = N_UNQ(range_node);
  63.     else {
  64.         if (kind == as_subtype) {
  65.             type_node = N_AST1(range_node);
  66.             new_range_node = N_AST2(range_node);
  67.             low_node  = N_AST1(new_range_node);
  68.             high_node = N_AST2(new_range_node);
  69.         }
  70.         else if (kind == as_range) {
  71.             low_node = N_AST1(range_node);
  72.             high_node = N_AST2(range_node);
  73.         }
  74.         else if (kind == as_attribute) {
  75.             /*att_node = N_AST1(range_node); -- not needed in C */
  76.             arg1 = N_AST2(range_node);
  77.             arg2 = N_AST3(range_node);
  78.             /* subtract code for ATTR_FIRST to get T_ or O_ value */
  79.             /* recall that in C attribute kind kept in range_node*/
  80.             attr_prefix = (int)attribute_kind(range_node)-ATTR_RANGE;
  81.             /* 'T' or 'O' */
  82.             attribute_kind(range_node) = (char *)((int) attr_prefix+ATTR_FIRST);
  83.             low_node = range_node;
  84.             high_node = new_attribute_node(attr_prefix+ATTR_LAST,
  85.               copy_node(arg1), copy_node(arg2), get_type(range_node));
  86.             eval_static(low_node);
  87.             eval_static(high_node);
  88.         }
  89.         else {
  90. #ifdef ERRNUM
  91.             errmsgn(342, 343, range_node);
  92. #else
  93.             errmsg("Unexpected range in slice", "", range_node );
  94. #endif
  95.             low_node = OPT_NODE;
  96.             high_node = OPT_NODE;
  97.         }
  98.         /* We need the bounds twice, for the slice and for the aggregate
  99.          * so we build an anonymous subtype to avoid double evaluation
  100.          */
  101.         if (N_KIND(array_node) == as_simple_name
  102.           || N_KIND(array_node) == as_name)
  103.             type_mark = TYPE_OF(N_UNQ(array_node));
  104.         else
  105.             type_mark = N_TYPE(array_node);
  106.         type_mark = base_type(type_mark);        /* get base type */
  107.         index_name = named_atom("slice_index_type");
  108.         type_name = named_atom("slice_type");
  109.         i_type= (Symbol) index_type(type_mark);
  110.         tup = constraint_new(0);
  111.         tup[2] = (char *) low_node;
  112.         tup[3] = (char *) high_node;
  113.         new_symbol(index_name, na_subtype, i_type, tup, ALIAS(i_type));
  114.         SCOPE_OF(index_name) = scope_name;
  115.  
  116.         tup = constraint_new(4);
  117.         tup[1] = (char *) tup_new1((char *) index_name);
  118.         tup[2] = (char *) component_type(type_mark);
  119.  
  120.         new_symbol(type_name, na_subtype, type_mark, tup, ALIAS(type_mark));
  121.         SCOPE_OF(type_name) = scope_name;
  122.         tup = tup_new(2);
  123.         tup[1] = (char *) new_subtype_decl_node(index_name);
  124.         tup[2] = (char *) new_subtype_decl_node(type_name);
  125.         make_insert_node(node, tup, copy_node(node));
  126.         N_AST1(var_node)  = array_node;
  127.         N_AST2(var_node)  = new_name_node(index_name);
  128.         copy_span(range_node, N_AST2(var_node));
  129.     }
  130.     return type_name;
  131. }
  132.  
  133. static void new_symbol(Symbol new_name, int new_nature, Symbol new_type,
  134.   Tuple new_signature, Symbol new_alias)                        /*;new_symbol*/
  135. {
  136.     NATURE(new_name)    = new_nature;
  137.     TYPE_OF(new_name)    = new_type;
  138.     SIGNATURE(new_name) = new_signature;
  139.     ALIAS(new_name)    = new_alias;
  140.     dcl_put(DECLARED(scope_name), str_newat(), new_name);
  141. }
  142.  
  143. Symbol get_type(Node node)                                        /*;get_type*/
  144. {
  145.     /*
  146.      * GET_TYPE is procedure get_type() in C:
  147.      *     macro GET_TYPE(node);
  148.      *  (if N_KIND(node) in [as_simple_name, as_subtype_indic]
  149.      *                        then TYPE_OF(N_UNQ(node))
  150.      *                        }
  151.      *                        else N_TYPE(node) end )                   endm;
  152.      */
  153.  
  154.     int    nk;
  155.     Symbol    sym;
  156.  
  157.     nk = N_KIND(node);
  158.     if (nk == as_simple_name || nk == as_subtype_indic) {
  159.         sym = N_UNQ(node);
  160.         if (sym == (Symbol)0) {
  161. #ifdef DEBUG
  162.             zpnod(node);
  163. #endif
  164.             chaos("get_type: N_UNQ not defined for node");
  165.         }
  166.         else
  167.             sym =  TYPE_OF(sym);
  168.     }
  169.     else
  170.         sym = N_TYPE(node);
  171.  
  172.     return sym;
  173. }
  174.  
  175. void assign_statement(Node node)  /*;assign_statement*/ 
  176. {
  177.     Node var_node, exp_node;
  178.     Symbol t, t1, t2, ok_sym;
  179.     Set    t_l, t_left, t_right, ok_types, ook_types;
  180.     Forset    tiv, tforl, tforr, fs1;
  181.  
  182.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  assign_statement");
  183.  
  184.     var_node = N_AST1(node);
  185.     exp_node = N_AST2(node);
  186.  
  187.     noop_error = FALSE;        /* To clear previous type errors */
  188.  
  189.     adasem(var_node);
  190.     find_old(var_node);            /* left-hand side is a name.*/
  191.     adasem(exp_node);
  192.  
  193.     resolve1(var_node);
  194.     t_l = N_PTYPES(var_node);
  195.     t_left = set_new(0);
  196.     FORSET(t = (Symbol), t_l, tiv);
  197.         if (! is_limited_type(t)) t_left = set_with(t_left, (char *) t);
  198.     ENDFORSET(tiv);
  199.     resolve1(exp_node);
  200.     t_right = N_PTYPES(exp_node);
  201.  
  202.     if (noop_error) {    /* previous error. */
  203.         noop_error = FALSE;
  204.         return;
  205.     }
  206.  
  207.     ok_types = set_new(0);
  208.     FORSET(t1 = (Symbol), t_left, tforl);
  209.         FORSET(t2 = (Symbol), t_right, tforr);
  210.             if (compatible_types(t1, t2) )
  211.                 ok_types = set_with(ok_types, (char *) t1);
  212.         ENDFORSET(tforr);
  213.     ENDFORSET(tforl);
  214.     /* For the assignment to be unambiguous, the left-hand and right_hand
  215.      * sides must have a single compatible interpretation.
  216.      */
  217.     if (set_size(ok_types) == 0) {
  218.         if (set_size(t_l) == 1 && set_size(t_left) == 0) {
  219. #ifdef ERRNUM
  220.             errmsgn(344, 278, var_node);
  221. #else
  222.             errmsg("assignment not available on a limited type", "7.4.2",
  223.               var_node);
  224. #endif
  225.             set_free(ok_types);
  226.             return;
  227.         }
  228.         else {
  229. #ifdef ERRNUM
  230.             errmsgn(345, 346, node);
  231. #else
  232.             errmsg("incompatible types for assignment", "5.2", node);
  233. #endif
  234.             set_free(ok_types);
  235.             return;
  236.         }
  237.     }
  238.     else if (set_size(ok_types) > 1) {    /* ambiguous left-hand side */
  239.         remove_conversions(var_node);        /* last chance. */
  240.         ook_types = ok_types;
  241.         ok_types = set_new(0);
  242.         FORSET(ok_sym=(Symbol), N_PTYPES(var_node), fs1);
  243.             if (set_mem((char *) ok_sym, ook_types))
  244.                 ok_types = set_with(ok_types, (char *)ok_sym);
  245.         ENDFORSET(fs1);
  246.         set_free(ook_types);
  247.         if (set_size(ok_types) != 1) {
  248. #ifdef ERRNUM
  249.             errmsgn(347, 346, var_node);
  250. #else
  251.             errmsg("ambiguous types for assigment", "5.2", var_node);
  252. #endif
  253.             set_free(ok_types);
  254.             return;
  255.         }
  256.     }
  257.     t1 = (Symbol) set_arb(ok_types);  /* Now unique. */
  258.     set_free(ok_types);
  259.     out_context = TRUE;
  260.     resolve2(var_node, t1);
  261.     out_context = FALSE;
  262.     /*if (N_KIND(var_node) == as_slice && (N_KIND(exp_node) == as_aggregate
  263.         ||N_KIND(exp_node) == as_string_literal)){*/
  264.  
  265.     /* we don't have to care about the type of the right hand side cf Setl */
  266.     if (N_KIND(var_node) == as_slice) {
  267.         /* context is constrained, even though type of lhs is base type
  268.          * This means that an OTHERS association is allowed.
  269.          */
  270.         t1 = slice_type(node,0);
  271.         resolve2 (exp_node, t1);
  272.         return;
  273.     }
  274.  
  275.     if(NATURE(t1) == na_array && N_UNQ(var_node) != (Symbol)0 &&
  276.       (NATURE(N_UNQ(var_node))==na_inout || NATURE(N_UNQ(var_node))==na_out))
  277.         replace_others(exp_node, var_node, tup_size(index_types(t1)), 1);
  278.  
  279.     resolve2(exp_node, t1);
  280.  
  281.     if (! is_variable(var_node)){
  282. #ifdef ERRNUM
  283.         errmsgn(348, 346, var_node);
  284. #else
  285.         errmsg("left-hand side in assignment is not a variable", "5.2",
  286.           var_node);
  287. #endif
  288.         return;
  289.     }
  290.  
  291.     if (is_array(t1) ) {
  292.         /* array assignments are length_checked in the interpreter, and don't
  293.          * carry a qualification.
  294.          */
  295.         ;
  296.     }
  297.     else if (!in_qualifiers(N_KIND(exp_node))) {
  298.         /* a constraint check on the right hand side may be needed.*/
  299.         N_TYPE(exp_node) = base_type(t1);
  300.         apply_constraint(exp_node, t1);
  301.     }
  302.     eval_static(var_node);
  303.     eval_static(exp_node);
  304.  
  305.     noop_error = FALSE;        /* clear error flag */
  306. }
  307.  
  308. static void replace_others(Node agg_node, Node var_node, int max_dim, int dim)
  309.                                                             /*;replace_others*/
  310. {
  311.     /* This function's sole purpose is to replace the OTHERS choice in an
  312.      *  array aggregate with a RANGE choice, when the OTHERS is the only
  313.      *  choice and the aggregate is on the right side of an assignment
  314.      *  statement.  It presumes that the aggregate is properly formed
  315.      *  since that is checked elsewhere. It must call itself recursively
  316.      *  to check the higher numbered dimensions.
  317.      */
  318.  
  319.     Node association, choice_list, choices, choice;
  320.     Tuple assoc_list;
  321.     Fortup ft1;
  322.  
  323.     /* Check conditions allowing immediate return */
  324.     if (N_KIND(agg_node) != as_aggregate)
  325.         return;
  326.     if (dim > max_dim)  /* All dimensions have been checked */
  327.         return;
  328.     if ((assoc_list = N_LIST(agg_node)) == (Tuple)0 || tup_size(assoc_list) ==0)
  329.         /* Return if no entries (component associations) in aggregate */
  330.         return;
  331.  
  332.     /* Recursive call for each association's expression */
  333.     FORTUP(association = (Node), assoc_list, ft1)
  334.         replace_others(N_AST2(association), var_node, max_dim, dim + 1);
  335.     ENDFORTUP(ft1)
  336.  
  337.     /* Check for OTHERS to be replaced */
  338.     if (tup_size(assoc_list) != 1) return;
  339.     choice_list = (Node)assoc_list[1];
  340.     if (N_KIND(choice_list) != as_choice_list) return;
  341.     choices = N_AST1(choice_list);
  342.     if (N_LIST(choices) == (Tuple)0) return;
  343.     if (tup_size(N_LIST(choices)) != 1) return;
  344.     choice = (Node)N_LIST(choices)[1];
  345.     if (N_KIND(choice) != as_others_choice) return;
  346.  
  347.     /* Replace */
  348.     N_KIND(choice) = as_range_choice;
  349.     choice = (N_AST1(choice) = node_new(as_attribute));
  350.     N_AST1(choice) = node_new(as_number);
  351.     N_VAL(N_AST1(choice)) = (char *)ATTR_RANGE;
  352.     N_AST2(choice) = copy_node(var_node);
  353.     N_AST3(choice) = OPT_NODE;
  354. }
  355.  
  356. int is_variable(Node node)  /*;is_variable*/  
  357. {
  358.     /* Verify that an expression is a variable name. This is called for
  359.      * assignment statements, when validating  -out- and -inout-
  360.      * parameters in a procedure or entry call, and for generic inout parms.
  361.      */
  362.  
  363.     Node array_node, sel_node;
  364.     Node rec_node, exp_node;
  365.     int    nat ;
  366.  
  367.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_variable");
  368.  
  369.     switch (N_KIND(node)) {
  370.     case as_simple_name:
  371.         nat = NATURE(N_UNQ(node));
  372.         return ( nat == na_obj || nat == na_inout || nat == na_out);
  373.     case as_index:
  374.     case as_slice:
  375.         array_node  = N_AST1(node);
  376.         return (is_variable(array_node) );
  377.     case as_selector:
  378.         rec_node = N_AST1(node);
  379.         sel_node= N_AST2(node);
  380.         return (is_variable(rec_node) && NATURE(N_UNQ(sel_node)) == na_obj );
  381.     case as_all:
  382.         /* access_node = N_AST1(node);
  383.          * return (N_KIND(access_node) == as_simple_name ||
  384.          *   is_variable(access_node) ||
  385.          *   N_KIND(access_node) == as_call
  386.          *   && is_access(N_TYPE(access_node))
  387.          *     );
  388.          */
  389.         return TRUE; /* designated object is always assignable */
  390.     case as_convert:
  391.         exp_node = N_AST2(node);
  392.         return (is_variable(exp_node));
  393.     default:
  394.         return FALSE;
  395.     }
  396. }
  397.  
  398. void statement_list(Node node)  /*;statement_list*/
  399. {
  400.     Node    stmt_list, label_list, l;
  401.     Symbol    ls;
  402.     int    i;
  403.     Fortup    ft1;
  404.     Tuple    labs;
  405.     stmt_list = N_AST1(node);
  406.     label_list = N_AST2(node);
  407.  
  408.     /* labs := [N_UNQ(l) : l in N_LIST(label_list)]; */
  409.     labs = tup_new(tup_size(N_LIST(label_list)));
  410.     FORTUPI(l = (Node), N_LIST(label_list), i, ft1);
  411.         labs[i] = (char *) N_UNQ(l);
  412.     ENDFORTUP(ft1);
  413.     /* Within the statement list, all labels defined therein are reachable
  414.      * by goto statements in that list.
  415.      */
  416.     FORTUP(ls = (Symbol), labs, ft1);
  417.         label_status(ls) = (Tuple) label_reachable;
  418.     ENDFORTUP(ft1);
  419.     FORTUP(l = (Node), N_LIST(stmt_list), ft1);
  420.         if (N_KIND(l) != as_line_no)
  421.             adasem(l);
  422.     ENDFORTUP(ft1);
  423.  
  424.     /* On exit, these labels become unreachable.*/
  425.     FORTUP(ls = (Symbol), labs, ft1);
  426.         label_status(ls) = (int) label_unreachable;
  427.     ENDFORTUP(ft1);
  428.     tup_free(labs);
  429. }
  430.  
  431. void if_statement(Node node)                               /*;if_statement*/
  432. {
  433.     Fortup    ft1;
  434.     Node    cond_node, stmt_node, if_list, else_node, tnode;
  435.  
  436.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  if_statement");
  437.  
  438.     if_list = N_AST1(node);
  439.     else_node = N_AST2(node);
  440.  
  441.     FORTUP(tnode = (Node), N_LIST(if_list), ft1);
  442.         cond_node = N_AST1(tnode);
  443.         stmt_node = N_AST2(tnode);
  444.         adasem(cond_node);
  445.         adasem(stmt_node);
  446.     ENDFORTUP(ft1);
  447.  
  448.     adasem(else_node);
  449. }
  450.  
  451. void case_statement(Node node)                              /*;case_statement*/
  452. {
  453.     Symbol    exptype;
  454.     Node    exp_node, cases;
  455.  
  456.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  case_statement");
  457.  
  458.     exp_node = N_AST1(node);
  459.     cases = N_AST2(node);
  460.  
  461.     adasem(exp_node);
  462.     check_type_d(exp_node);
  463.     exptype = N_TYPE(exp_node);
  464.  
  465.     if (exptype == symbol_any)         /* Type error. */
  466.         return;
  467.     else
  468.         if (exptype == symbol_universal_integer)
  469.             /*exptype = symbol_integer;*/
  470.             specialize(exp_node, symbol_integer);
  471.  
  472.     process_case(exptype, cases);
  473. }
  474.  
  475. void process_case(Symbol exptype, Node cases)  /*;process_case*/
  476. {
  477.  
  478.     Forset    fs1;
  479.     int invalid_case_type;
  480.     Symbol    exp_base_type;
  481.     Node        exp_lo, exp_hi;
  482.     int    t;
  483.     int        exp_lov, exp_hiv, range_size;
  484.     Tuple    case_list, cs, tup, sig, choice_alt;
  485.     int        is_others_part;
  486.     Set        valset;
  487.     int        numval;
  488.     Node    stmt_list, choice_list, c, ch, choices;
  489.     Node    choice, lo, hi, last_choices, alternative;
  490.     Node    constraint, tmpnode;
  491.     Symbol    choicev;
  492.     int        lov, hiv, is_static;
  493.     Tuple numcon;
  494.     Node    stmts;
  495.     int        range_choice, duplicate_choice, a, b;
  496.     Fortup    ft1, ft2;
  497.     Const    con;
  498.  
  499.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  process_case");
  500.  
  501.     /* This procedure is given the type of the case expression and
  502.      * uses this type to resolve the choices appearing in the case_list.
  503.      * It also checks that the choices are static expressions and
  504.      * constructs the case statement intermediate code.
  505.      * It is called both for case statements and for variant parts.
  506.      *
  507.      * The case_list has the form
  508.      *
  509.      *    case_list ::= [ [choice_list, statement_list] ... ]
  510.      *
  511.      * where a choice_list is a sequence of choices,
  512.      *
  513.      *    choice_list ::= [choice ...]
  514.      *
  515.      * each of the form
  516.      *
  517.      *    choice ::= ["simple_choice", simp_expr ]
  518.      *          |["range_coice",   discr_range]
  519.      *          |["others_choice", OPT_NODE]
  520.      *
  521.      *
  522.      *    case_statement ::= ["case", expr, altlist, others]
  523.      *
  524.      * where
  525.      *    altlist     ::=  { {choice} -> statement_list}
  526.      * and
  527.      *    choice ::=  choiceval | ["range", choiceval, choiceval]
  528.      *
  529.      * On exit, the VAL field of each choice list is the set of discrete
  530.      * values corresponding to the choices in the list.
  531.      */
  532.     if (cdebug2 > 0) {
  533. #ifdef ERRMSG
  534.         TO_ERRFILE("case evaluation", exptype);
  535. #endif
  536.         TO_ERRFILE("case evaluation");
  537.     }
  538.  
  539.     /* Check that the case expression is of a discrete type
  540.      * and that its range is static, and find the length of
  541.      * the range.
  542.      *
  543.      */
  544.     invalid_case_type = FALSE;
  545.  
  546.     exp_base_type = base_type(exptype);
  547.  
  548.     if ( !is_discrete_type(exp_base_type)) {
  549. #ifdef ERRNUM
  550.         errmsgn(349, 350, cases);
  551. #else
  552.         errmsg("Case expression not of discrete type", "3.7.3, 5.4", cases);
  553. #endif
  554.         invalid_case_type = TRUE;    /* Still check the alternatives*/
  555.  
  556.     }
  557.     else if (is_generic_type(exp_base_type)) {
  558. #ifdef ERRNUM
  559.         errmsgn(351, 352, cases);
  560. #else
  561.         errmsg("Case expression cannot be of a generic type", "5.4", cases);
  562. #endif
  563.         invalid_case_type = TRUE;
  564.     }
  565.  
  566.     numcon = (Tuple) SIGNATURE(exptype);
  567.     if (numcon == (Tuple) 0 ) {
  568.         exp_lo = (Node)0;
  569.         exp_hi = (Node)0;
  570.     }
  571.     else {
  572.         exp_lo = (Node) numeric_constraint_low(numcon);
  573.         exp_hi = (Node) numeric_constraint_high(numcon);
  574.     }
  575.  
  576.     is_static = is_static_subtype(exptype);
  577.  
  578.     if (! is_static) {
  579.         tup = SIGNATURE(exp_base_type);
  580.         if (tup == (Tuple)0 ) {
  581.             exp_lo = (Node)0;
  582.             exp_hi = (Node)0;
  583.         }
  584.         else {
  585.             exp_lo = (Node) tup[2];
  586.             exp_hi = (Node) tup[3];
  587.         }
  588.         if (! is_static_expr(exp_lo) || !is_static_expr(exp_hi))
  589.             /* This alternative can arise only if the type of the
  590.              * case expression does not have static bounds.  This
  591.              * has alreay been caught, so we give no error message here,
  592.              * but only the choices are type checked and no code put out.
  593.              */
  594.             invalid_case_type = TRUE;
  595.     }
  596.  
  597.     if (! invalid_case_type) {
  598.         con = (Const) N_VAL(exp_lo);
  599.         exp_lov = (int) con->const_value.const_int;
  600.         con = (Const) N_VAL(exp_hi);
  601.         exp_hiv = con->const_value.const_int;
  602.         t = (exp_hiv - exp_lov + 1);
  603.         range_size = t > 0 ? t : 0;
  604.     }
  605.  
  606.     /* Now check each of the case choices against exp_base_type, and ensure
  607.      * that each is static.
  608.      */
  609.     case_list = N_LIST(cases);
  610.  
  611.     FORTUP(c =(Node), case_list, ft1);
  612.         /* Process statements or declarations, and resolve names in*/
  613.         /* choice expressions. */
  614.         choices = N_AST1(c);
  615.         stmts = N_AST2(c);
  616.         sem_list(choices);
  617.         adasem(stmts);
  618.     ENDFORTUP(ft1);
  619.  
  620.     is_others_part = FALSE;
  621.     valset = set_new(0);
  622.     numval = 0;
  623.     if (tup_size(case_list)) { /* empty case list is allowed */
  624.         tmpnode = (Node) case_list[tup_size(case_list)];
  625.         last_choices = N_AST1(tmpnode);
  626.         cs = N_LIST(last_choices);
  627.         if (tup_size(cs) == 1 && N_KIND((Node)cs[1]) == as_others_choice) {
  628.             is_others_part = TRUE;
  629.             /* label the whole alternative as an OTHERS choice .*/
  630.             N_KIND(tmpnode) = as_others_choice;
  631.         }
  632.  
  633.         FORTUP(alternative =(Node) , case_list, ft1);
  634.             choice_list = N_AST1(alternative);
  635.             stmt_list   = N_AST2(alternative);
  636.             choice_alt  = tup_new(0);
  637.  
  638.             FORTUP(ch=(Node), N_LIST(choice_list), ft2);
  639.                 if (N_KIND(ch) == as_others_choice) {
  640.                     is_others_part = TRUE;
  641.                     continue;
  642.                 }
  643.                 choice = N_AST1(ch);
  644.                 /* Type check the choice and  ensure that it is static,
  645.                  * in the range    for the expression  subtype, and  that
  646.                  * it appears no more than once in the list of values.
  647.                  */
  648.  
  649.                 if (N_KIND(ch) == as_choice_unresolved ) {
  650.                     find_old(choice);
  651.                     choicev = N_UNQ(choice);
  652.                     if (is_type (choicev) ) {
  653.                         if (! compatible_types(choicev, exp_base_type)) {
  654. #ifdef ERRNUM
  655.                             id_errmsgn(353, exp_base_type, 352, ch);
  656. #else
  657.                             errmsg_id("Choice must have type %", exp_base_type,
  658.                               "5.4", ch);
  659. #endif
  660.                             continue;
  661.                         }
  662.                         sig = SIGNATURE(choicev);
  663.                         lo = (Node) sig[2];
  664.                         hi = (Node) sig[3];
  665.                         if (is_static_expr(lo) && is_static_expr(hi) ) {
  666.                             eval_static(lo);
  667.                             con = (Const) N_VAL(lo);
  668.                             lov = con->const_value.const_int;
  669.                             eval_static(hi);
  670.                             con = (Const) N_VAL(hi);
  671.                             hiv = con->const_value.const_int;
  672.                         }
  673.                         else {
  674. #ifdef ERRNUM
  675.                             errmsgn(354, 350, ch);
  676. #else
  677.                             errmsg("Case choice not static", "3.7.3, 5.4", ch);
  678. #endif
  679.                             continue;
  680.                         }
  681.                         /* Reformat node as a simple type name. */
  682.                         copy_attributes(choice, ch);
  683.                     }
  684.                     else        /* expression: resolve below.*/
  685.                         N_KIND(ch) = as_simple_choice;
  686.                 }
  687.                 if (N_KIND(ch) == as_simple_choice) {
  688.                     check_type(exp_base_type, choice);
  689.  
  690.                     if (N_TYPE(choice) == symbol_any || invalid_case_type )
  691.                         continue;
  692.                     else if (is_static_expr(choice)) {
  693.                         con = get_static_nval(choice);
  694.                         if (con == (Const)0)   /* previous error (?) */
  695.                             continue;
  696.                         lov = con->const_value.const_int;
  697.                         lo = hi = choice;
  698.                         hiv = lov;
  699.                     }
  700.                     else {
  701. #ifdef ERRNUM
  702.                         errmsgn(354, 350, ch);
  703. #else
  704.                         errmsg("Case choice not static", "3.7.3, 5.4", ch);
  705. #endif
  706.                         continue;
  707.                     }
  708.                 }
  709.                 else if (N_KIND(ch) == as_range_choice) {
  710.                     check_type(exp_base_type, choice);
  711.                     if (N_TYPE(choice) == symbol_any || invalid_case_type)
  712.                         continue;
  713.                     else {
  714.                         constraint = N_AST2(choice);
  715.                         lo = N_AST1(constraint);
  716.                         hi = N_AST2(constraint);
  717.                         if (is_static_subtype(N_TYPE(choice))
  718.                           && is_static_expr(lo) && is_static_expr(hi)) {
  719.                             con = get_static_nval(lo);
  720.                             lov = con->const_value.const_int;
  721.                             con = get_static_nval(hi);
  722.                             hiv = con->const_value.const_int;
  723.                         }
  724.                         else {
  725. #ifdef ERRNUM
  726.                             errmsgn(354, 350, ch);
  727. #else
  728.                             errmsg("Case choice not static", "3.7.3, 5.4", ch);
  729. #endif
  730.                             continue;
  731.                         }
  732.                     }
  733.                 }
  734.             /* At this point the choice is known to be static and is expressed
  735.              * as a range [lov, hiv].
  736.              */
  737.                 if (is_static && (lov<=hiv) && (lov<exp_lov || hiv > exp_hiv)) {
  738. #ifdef ERRNUM
  739.                     l_errmsgn(355, 356, 352, ch);
  740. #else
  741.                     errmsg_l("choice value(s) not in range of static ",
  742.                       "subtype of case expression", "5.4", ch);
  743. #endif
  744.                 }
  745.                 /* Remove junk values from below*/
  746.                 if (lov < exp_lov) lov = exp_lov;
  747.                 /* Remove junk values from above*/
  748.                 if (hiv > exp_hiv) hiv = exp_hiv;
  749.  
  750.                 /* normalize all nodes to be ranges. */
  751.                 N_KIND(ch) = as_range;
  752.                 N_AST1(ch) = lo;
  753.                 N_AST2(ch) = hi;
  754.  
  755.                 if (lov > hiv )            /* Null range -- ignore it.*/
  756.                     continue;
  757.  
  758.                 /* Ensure that range is disjoint from all others. */
  759.  
  760.                 range_choice = hiv > lov;
  761.                 duplicate_choice = FALSE;
  762.  
  763.                 FORSET(tup =(Tuple) , valset, fs1);
  764.                     if (lov >= (int) tup[1] && lov <= (int)tup[2]) {
  765.                         duplicate_choice = TRUE;
  766.                         lov = (int)tup[2] + 1;
  767.                         break;
  768.                     }
  769.                 ENDFORSET(fs1);
  770.  
  771.                 if (range_choice) {
  772.                     FORSET(tup = (Tuple), valset, fs1);
  773.                         a = (int) tup[1]; 
  774.                         b = (int) tup[2];
  775.                         if (hiv >= a && hiv <= b) {
  776.                             duplicate_choice = TRUE;
  777.                             hiv = a - 1;
  778.                             break;
  779.                         }
  780.                     ENDFORSET(fs1);
  781.                 }
  782.                 if (range_choice) {
  783.                     FORSET(tup = (Tuple), valset, fs1);
  784.                         a = (int) tup[1]; 
  785.                         b = (int) tup[2];
  786.                         if (lov<a && hiv>b) {
  787.                             duplicate_choice = TRUE;
  788.                             break;
  789.                         }
  790.                     ENDFORSET(fs1);
  791.                 }
  792.                 if (duplicate_choice) {
  793. #ifdef ERRNUM
  794.                     errmsgn(357, 350, ch);
  795. #else
  796.                     errmsg("Duplicate choice value(s)", "3.7.3, 5.4", ch);
  797. #endif
  798.                 }
  799.  
  800.                 if (lov > hiv)                /*Again check for null range*/
  801.                     continue;
  802.  
  803.                 /* Add interval to set of values seen so far, add the number 
  804.                   * of choices to the count of values covered. 
  805.                   */
  806.                 tup = tup_new(2);
  807.                 tup[1] = (char *) lov;
  808.                 tup[2] = (char *) hiv;
  809.                 valset = set_with(valset, (char *)tup);
  810.                 numval += (hiv - lov + 1);
  811.  
  812.                 /* finally, normalize all nodes to be discrete ranges. */
  813.                 N_KIND(ch) = as_range;
  814.                 N_AST1(ch) = lo;
  815.                 N_AST2(ch) = hi;
  816.             ENDFORTUP(ft2);
  817.         ENDFORTUP(ft1);
  818.     }
  819.     /* Check that all of the possibilities in the range of the
  820.      * case expression have been used.
  821.      */
  822.     if  (! invalid_case_type && ! is_others_part
  823.       && (numval != range_size || exptype == symbol_universal_integer))
  824.     {
  825. #ifdef ERRNUM
  826.         errmsgn(358, 350, cases);
  827. #else
  828.         errmsg("Missing OTHERS choice", "3.7.3, 5.4", cases);
  829. #endif
  830.     }
  831. }
  832.  
  833. int is_static_subtype(Symbol subtype)  /*;is_static_subtype*/
  834. {
  835.     Symbol    bt;
  836.     Node lo, hi;
  837.     Tuple tup;
  838.  
  839.     bt = TYPE_OF(subtype);
  840.     if (is_generic_type(bt) || in_incp_types(bt) || (! is_scalar_type(bt)))
  841.         /*  RM 4.9 (11) */
  842.         return FALSE;
  843.     else if (bt == subtype)
  844.         return TRUE;
  845.     else {
  846.         tup = (Tuple) SIGNATURE(subtype);
  847.         lo = (Node) tup[2];
  848.         tup = (Tuple) SIGNATURE(subtype);
  849.         hi = (Node) tup[3];
  850.         return (is_static_subtype(bt)
  851.           && N_KIND(lo) == as_ivalue && N_KIND(hi) == as_ivalue);
  852.     }
  853. }
  854.  
  855. static Const get_static_nval(Node node)            /*;get_static_nval */
  856. {
  857.     /* a choice may be a qualification, or it may carry a (spurious) constraint
  858.      * check. Reformat node to be a ivalue, as we know it is in bounds.
  859.      */
  860.  
  861.     int kind;
  862.  
  863.     kind = N_KIND(node);
  864.     if (kind == as_qual_range) {
  865.         copy_attributes(N_AST1(node), node);
  866.         return get_static_nval(node);
  867.     }
  868.     else if (kind == as_qualify || kind == as_convert) {
  869.         copy_attributes(N_AST2(node), node);
  870.         return get_static_nval(node);
  871.     }
  872.     else return (Const)N_VAL(node);
  873. }
  874.  
  875. void new_block(Node node)                                /*;new_block*/
  876. {
  877.     Node    id_node, decl_node, stmt_node, handler_node;
  878.     Symbol    block_name;
  879.  
  880.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_block");
  881.  
  882.     id_node = N_AST1(node);
  883.     decl_node  = N_AST2(node);
  884.     stmt_node = N_AST3(node);
  885.     handler_node = N_AST4(node);
  886.  
  887.     /* block names are declared when procedure containing them is entered. */
  888.     block_name = N_UNQ(id_node);
  889.  
  890.     NATURE(block_name) = na_block;
  891.     newscope(block_name);
  892.     adasem(decl_node);
  893.     adasem(stmt_node);
  894.     adasem(handler_node);
  895.     check_incomplete_decls(block_name, decl_node);
  896.     popscope();
  897.     force_all_types();
  898. }
  899.  
  900. void loop_statement(Node node)                          /*;loop_statement*/
  901. {
  902.     Tuple    t;
  903.     Symbol    loop_name;
  904.     Node    id_node, iter_node, stmt_node;
  905.  
  906.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  loop_statement");
  907.  
  908.     id_node = N_AST1(node);
  909.     iter_node  = N_AST2(node);
  910.     stmt_node = N_AST3(node);
  911.  
  912.     /* loop names are declared when procedure containing them is entered.*/
  913.  
  914.     find_old(id_node);
  915.     loop_name = N_UNQ(id_node);
  916.     NATURE(loop_name) = na_block;
  917.     OVERLOADS(loop_name) = (Set) BLOCK_LOOP;
  918.     t = tup_new(1);
  919.     t[1] = (char *) FALSE;
  920.     SIGNATURE(loop_name) = t;
  921.     /* The loop is the scope of definition of the iteration variable.  */
  922.     newscope(loop_name);
  923.     adasem(iter_node);
  924.     adasem(stmt_node);
  925.  
  926.     popscope();    /* Exit from loop scope.*/
  927. }
  928.  
  929. /*?? is return needed */
  930. Symbol iter_var(Node node)  /*;iter_var*/
  931. {
  932.     Node    id_node, range_node, def_node;
  933.     Symbol    loop_var, iter_type, type_def;
  934.     Tuple    t, tt, toptup, it;
  935.     int    n; 
  936.     char *id;
  937.  
  938.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  iter_var");
  939.  
  940.     id_node = N_AST1(node);
  941.     range_node = N_AST2(node);
  942.     adasem(range_node);
  943.     id = N_VAL(id_node);
  944.  
  945.     /* Insert loop variable in scope of loop. */
  946.     loop_var = find_new(id);
  947.     N_UNQ(id_node) = loop_var;
  948.  
  949.     /* If the iteration is given by a discrete range, construct an anonymous
  950.      * type for it, and save the defining expression. It is     emitted as part
  951.      * of the loop header.
  952.      */
  953.     iter_type = make_index(range_node);  /* $$$ PERHAPS */
  954.     n = tup_size(newtypes);
  955.     toptup = (Tuple) newtypes[n]; /* top newtypes */
  956.     if ((Symbol)toptup[tup_size(toptup)] == iter_type) {
  957.         /* Remove from anonymous types, and save subtype definition. */
  958.         it = (Tuple)tup_frome(toptup);
  959.         type_def = (Symbol) subtype_expr(iter_type);
  960.     }
  961.     else
  962.         type_def = (Symbol) tup_new(0);
  963.     NATURE(loop_var) = na_constant;
  964.     TYPE_OF(loop_var) = iter_type;
  965.     /* create dummy non-static default expression node for this (dummy) const */
  966.     def_node = node_new(as_simple_name);
  967.     N_VAL(def_node) = "";
  968. #ifdef IBM_PC
  969.     N_VAL(def_node) = strjoin("",""); /* copy literal */
  970. #endif
  971.     N_UNQ(def_node) = symbol_undef;
  972.     default_expr(loop_var) = (Tuple) def_node;
  973.  
  974.     t = tup_new(2);
  975.     t[1] = (char *) iter_type;
  976.     t[2] = (char *) type_def;
  977.     tt = SIGNATURE(scope_name);
  978.     tt = tup_with(tt, (char *) t);
  979.     SIGNATURE(scope_name) = tt;
  980.     return loop_var;
  981. }
  982.  
  983. void exit_statement(Node node)  /*;exit_statement*/
  984. {
  985.     Node    id_node, cond_node;
  986.     Symbol    scope, sc;
  987.     int    exists;
  988.     Fortup    ft1;
  989.     char    *id;
  990.     Tuple    tup;
  991.  
  992.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  exit_statement");
  993.  
  994.     id_node = N_AST1(node);
  995.     cond_node = N_AST2(node);
  996.  
  997.     /* An unqualified exit refers to the innermost enclosing scope.  */
  998.     if (id_node == OPT_NODE) {
  999.         exists = FALSE;
  1000.  
  1001.         FORTUP(scope = (Symbol), open_scopes, ft1);
  1002.             if ((int)OVERLOADS(scope) == BLOCK_LOOP) {
  1003.                 /* Indicate that loop label must be emitted. */
  1004.                 tup = SIGNATURE(scope); 
  1005.                 tup[1] = (char *)TRUE;
  1006.                 exists = TRUE;
  1007.                 break;
  1008.             }
  1009.         ENDFORTUP(ft1);
  1010.         if (! exists) {
  1011. #ifdef ERRNUM
  1012.             errmsgn(359, 360, node);
  1013. #else
  1014.             errmsg("EXIT statement not in loop", "5.7", node);
  1015. #endif
  1016.             return;
  1017.         }
  1018.     }
  1019.     else {
  1020.         id = N_VAL(id_node);
  1021.         /* Verify that loop label exists.*/
  1022.         exists = FALSE;
  1023.         FORTUP(scope = (Symbol), open_scopes, ft1);
  1024.             if (((int)OVERLOADS(scope) == BLOCK_LOOP)
  1025.               && streq(original_name(scope), id)) {
  1026.                 tup = SIGNATURE(scope);
  1027.                 tup[1] = (char *) TRUE;
  1028.                 exists = TRUE;
  1029.                 break;
  1030.             }
  1031.         ENDFORTUP(ft1);
  1032.         if (! exists) {
  1033. #ifdef ERRNUM
  1034.             str_errmsgn(361, id, 362, id_node);
  1035. #else
  1036.             errmsg_str("Invalid loop label in EXIT: %",id, "5.5, 5.7", id_node);
  1037. #endif
  1038.             return;
  1039.         }
  1040.     }
  1041.     N_UNQ(node) = scope;
  1042.  
  1043.     /* Now verify that the exit statement does not try to exit from
  1044.      * a procedure, task, package or accept statement. This amounts
  1045.      * to requiring that the scope stack contain only blocks up to the
  1046.      * scope being exited.
  1047.      */
  1048.     FORTUP(sc = (Symbol), open_scopes, ft1);
  1049.         if (sc == scope) break;
  1050.         else if (NATURE(sc) != na_block) {
  1051. #ifdef ERRNUM
  1052.             nat_errmsgn(363, sc, 360, node);
  1053. #else
  1054.             errmsg_nat("attempt to exit from %", sc, "5.7", node);
  1055. #endif
  1056.             break;
  1057.         }
  1058.     ENDFORTUP(ft1);
  1059.  
  1060.     adasem(cond_node);
  1061. }
  1062.  
  1063. void return_statement(Node node)                    /*;return_statement*/
  1064. {
  1065.     Node    exp_node, proc_node;
  1066.     int    j, nat, out_depth, certain;
  1067.     Symbol    r_type, proc_name, tsym;
  1068.     Fortup ft1;
  1069.     int    i, blktyp;
  1070.  
  1071.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  return_statement");
  1072.  
  1073.     exp_node = N_AST1(node);
  1074.  
  1075.     /* Find subprogram or accept statement which is enclosing scope, and keep
  1076.      * track of the     number     of blocks that     have  to  be exited. This number
  1077.      * is kept in the N_AST3 field for the node.
  1078.      * The N_AST of the node receives an additional
  1079.      * simple node to hold the unique name of the subprogram being exited. 
  1080.      */
  1081.     has_return_stk[tup_size(has_return_stk)] = (char *)TRUE;
  1082.  
  1083.     certain = FALSE;
  1084.     FORTUPI(proc_name = (Symbol), open_scopes, i, ft1);
  1085.         nat = NATURE(proc_name);
  1086.         if (nat != na_block) {
  1087.             certain = TRUE;
  1088.             break;
  1089.         }
  1090.     ENDFORTUP(ft1);
  1091.     out_depth = i - 1;
  1092.  
  1093.     /* Exception handlers are blocks for syntactic purposes, but not at
  1094.      * run-time. They must be excluded from this count.
  1095.      * The same is true for loops.
  1096.      */
  1097.     for (j = 1; j <= i; j++) {
  1098.         tsym = (Symbol) open_scopes[j];
  1099.         blktyp = (int)OVERLOADS(tsym);
  1100.         if (blktyp == BLOCK_HANDLER || blktyp == BLOCK_LOOP) out_depth -= 1;
  1101.     }
  1102.     if ((nat == na_function || nat == na_procedure 
  1103.       || nat == na_generic_function || nat == na_generic_procedure
  1104.       || nat == na_entry || nat == na_entry_family)) {
  1105.         ;
  1106.     }
  1107.     else {
  1108. #ifdef ERRNUM
  1109.         errmsgn(364, 365, node);
  1110. #else
  1111.         errmsg("invalid context for RETURN statement", "5.8", node);
  1112. #endif
  1113.         return;
  1114.     }
  1115.     r_type = nat == na_entry_family ? symbol_none : TYPE_OF(proc_name);
  1116.     if (exp_node != OPT_NODE) {
  1117.         if (r_type == symbol_none) {
  1118. #ifdef ERRNUM
  1119.             errmsgn(366, 365, exp_node);
  1120. #else
  1121.             errmsg("Procedure cannot return value", "5.8", exp_node);
  1122. #endif
  1123.         }
  1124.         else {
  1125.             /* If the value returned is an aggregate, there is no sliding
  1126.              * for it, and named associations can appear together with 
  1127.              * "others" (see 4.3.2(6)).
  1128.              */
  1129.             full_others = TRUE;
  1130.             adasem(exp_node);
  1131.             check_type(r_type, exp_node);
  1132.             full_others = FALSE;
  1133.         }
  1134.     }
  1135.     else if (r_type != symbol_none) {
  1136. #ifdef ERRNUM
  1137.         errmsgn(367, 365, node);
  1138. #else
  1139.         errmsg("Function must return value", "5.8", node);
  1140. #endif
  1141.     }
  1142.  
  1143.     proc_node = node_new(as_simple_name);
  1144.     N_UNQ(proc_node) = proc_name;
  1145.     N_AST1(node) =    exp_node;
  1146.     N_AST2(node) = proc_node;
  1147.     N_AST3(node) = new_number_node(out_depth);
  1148.     N_AST4(node) = (Node) 0;
  1149. }
  1150.  
  1151. void label_decl(Node node)                          /*;label_decl*/
  1152. {
  1153.     Symbol label;
  1154.     Fortup    ft1;
  1155.     char    *id;
  1156.     Tuple tlabs;
  1157.     Node    id_node;
  1158.  
  1159.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  label_decl");
  1160.  
  1161.     FORTUP(id_node = (Node), N_LIST(node), ft1);
  1162.         id = N_VAL(id_node);
  1163.         label = find_new(id);
  1164.         N_UNQ(id_node) = label;
  1165.         if (NATURE(label) == na_void
  1166.           && !tup_mem((char *) label , (Tuple) lab_seen[tup_size(lab_seen)])) {
  1167.             NATURE(label) = na_label;
  1168.             label_status(label) = (int) label_unreachable;
  1169.  
  1170.             /* top(lab_seen) with:= label; */
  1171.             tlabs = (Tuple) lab_seen[tup_size(lab_seen)];
  1172.             tlabs = tup_with(tlabs, (char *) label);
  1173.             lab_seen[tup_size(lab_seen)] = (char *) tlabs;
  1174.         }
  1175.         else {
  1176. #ifdef ERRNUM
  1177.             errmsgn(368, 3, id_node);
  1178. #else
  1179.             errmsg("Duplicate identifier for label", "5.1", id_node);
  1180. #endif
  1181.         }
  1182.     ENDFORTUP(ft1);
  1183. }
  1184.  
  1185. void lab_init()                                            /*;lab_init*/
  1186. {
  1187.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  lab_init ");
  1188.  
  1189.     lab_seen = tup_with(lab_seen, (char *) tup_new(0));
  1190. }
  1191.  
  1192. void lab_end()                                          /*;lab_end*/
  1193. {
  1194.     char    *old_labels;
  1195.  
  1196.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  lab_end ");
  1197.     /* The value of old_labels is irrelevant, as we are just removing
  1198.      * last element from lab_seen
  1199.      */
  1200.     old_labels = tup_frome(lab_seen);
  1201. }
  1202.  
  1203. void goto_statement(Node node)                           /*;goto_statement*/
  1204. {
  1205.     Node    id_node, id;
  1206.     Symbol    label, s;
  1207.     Fortup    ft1;
  1208.  
  1209.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  goto_statement");
  1210.  
  1211.     id_node = N_AST1(node);
  1212.     id = (Node) N_VAL(id_node); /*?? id is never used */
  1213.  
  1214.     find_old(id_node);
  1215.     label = N_UNQ(id_node);
  1216.  
  1217.     if (NATURE(label) != na_label) {
  1218. #ifdef ERRNUM
  1219.         errmsgn(369, 370, id_node);
  1220. #else
  1221.         errmsg("target of goto is not a label", "5.9", id_node);
  1222. #endif
  1223.  
  1224.     }
  1225.     else if ((int)label_status(label) == label_unreachable) {
  1226. #ifdef ERRNUM
  1227.         errmsgn(371, 370, id_node);
  1228. #else
  1229.         errmsg("target of goto is not a reachable label", "5.9", id_node);
  1230. #endif
  1231.     }
  1232.     else {
  1233.         FORTUP(s = (Symbol), open_scopes, ft1);
  1234.             if (s == SCOPE_OF(label)) break;
  1235.             else if (NATURE(s) != na_block) {
  1236. #ifdef ERRNUM
  1237.                 nat_errmsgn(372, s, 370, node);
  1238. #else
  1239.                 errmsg_nat("attempt to jump out of %", s, "5.9", node);
  1240. #endif
  1241.             }
  1242.  
  1243.         ENDFORTUP(ft1);
  1244.     }
  1245. }
  1246.